home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / 3d / vb3d2 / vb_code / easy3d2.bas < prev    next >
BASIC Source File  |  1995-09-29  |  9KB  |  275 lines
  1. ' ! This is a Visual Basic BAS-file !                     '
  2. ' ******************************************************* '
  3. ' *          Please download VB_3D.EXE first.           * '
  4. ' *     This file is a revision of prior versions.      * '
  5. ' *     This module does ONLY contain the revised       * '
  6. ' *     parts of code - please pass to EASY3D.BAS.      * '
  7. ' ******************************************************* '
  8. '                                                         '
  9. ' Now there are MANY 3D routines available for VB.        '
  10. ' This one is according to VB_3D.EXE by CIS:100540,2644   '
  11. ' which was according to VB3D.ZIP by CIS:100265,1725.     '
  12. '                                                         '
  13. '                                                         '
  14. '                        + + +                            '
  15. '                                                         '
  16. ' Feel free to use any part of code from this module.     '
  17. '                                                         '
  18. ' Code by: Christian Germelmann                           '
  19. '          35039 Marburg - Germany                        '
  20. '          CIS:100520,2644                                '
  21. '                                                         '
  22.  
  23. Option Explicit
  24.  
  25. Dim retInt%, retLng&, hInst%
  26.  
  27.  
  28. Global CTRL3D_Registered%
  29. Const GWW_HINSTANCE% = (-6)
  30. Const SEM_NOOPENFILEERRORBOX& = &H8000
  31.  
  32. Declare Sub ShellAbout Lib "SHELL" Alias "#22" (ByVal hWnd%, ByVal TitelText$, ByVal DialogText$, ByVal BildhWnd%)
  33.  
  34. Declare Function GetWindowWord% Lib "USER" Alias "#133" (ByVal hWnd%, ByVal nIndex%)
  35. Declare Function GetWindowLong& Lib "USER" Alias "#135" (ByVal hWnd%, ByVal nIndex%)
  36. Declare Function SetWindowLong& Lib "USER" Alias "#136" (ByVal hWnd%, ByVal nIndex%, ByVal dwNewLong&)
  37. Const GWL_STYLE& = (-16)
  38. Const COLOR_BTNFACE& = &H8000000F
  39. Const FIXED_DOUBLE% = 3
  40. Const DS_MODALFRAME& = &H80&
  41.  
  42. Declare Function GetSystemMenu% Lib "USER" Alias "#156" (ByVal hWnd%, ByVal bRevert%)
  43. Declare Function DeleteMenu% Lib "USER" Alias "#413" (ByVal hMenu%, ByVal nPosition%, ByVal wFlags%)
  44. Const SC_SEPARATOR& = &H0
  45. 'Global Const SC_MOVE& = &HF010
  46. Const SC_SIZE& = &HF000
  47. 'Global Const SC_MINIMIZE& = &HF020
  48. 'Global Const SC_MAXIMIZE& = &HF030
  49. 'Global Const SC_NEXTWINDOW& = &HF040
  50. 'Global Const SC_PREVWINDOW& = &HF050
  51. Const SC_CLOSE& = &HF060
  52. 'Global Const SC_ARRANGE& = &HF110
  53. 'Global Const SC_RESTORE& = &HF120
  54. Const SC_TASKLIST& = &HF130
  55.  
  56. Declare Function SetErrorMode% Lib "KERNEL" Alias "#107" (ByVal wMode As Integer)
  57. Declare Function GetWindowsDirectory% Lib "KERNEL" Alias "#134" (ByVal lpBuffer$, ByVal nSize%)
  58. Declare Function GetSystemDirectory% Lib "KERNEL" Alias "#135" (ByVal lpBuffer$, ByVal nSize%)
  59.  
  60.  
  61. ' ***********************************************************
  62. ' *                      Please note:                       *
  63. ' * different from prior releases the 3D.DLLs are no longer *
  64. ' *   declared as Functions but as Subs since they do not   *
  65. ' *   return any value. This shortens the code as shown.    *
  66. ' ***********************************************************
  67.  
  68. Declare Sub Ctl3dRegister Lib "CTL3D.DLL" Alias "#12" (ByVal hInst%)
  69. Declare Sub Ctl3dUnregister Lib "CTL3D.DLL" Alias "#13" (ByVal hInst%)
  70. Declare Sub Ctl3dAutoSubclass Lib "CTL3D.DLL" Alias "#16" (ByVal hInst%)
  71. Declare Sub Ctl3dSubclassDlgEx Lib "CTL3D.DLL" Alias "#21" (ByVal hWnd%, ByVal Flags&)
  72.  
  73. Declare Sub Ctl3dRegisterV2 Lib "CTL3DV2.DLL" Alias "#12" (ByVal hInst%)
  74. Declare Sub Ctl3dUnregisterV2 Lib "CTL3DV2.DLL" Alias "#13" (ByVal hInst%)
  75. Declare Sub Ctl3dAutoSubclassV2 Lib "CTL3DV2.DLL" Alias "#16" (ByVal hInst%)
  76. Declare Sub Ctl3dSubclassDlgExV2 Lib "CTL3DV2.DLL" Alias "#21" (ByVal hWnd%, ByVal Flags&)
  77.  
  78. ' **************************************************
  79. ' * If you are puzzled by the 'Alias' just scip it *
  80. ' **************************************************
  81.  
  82. '
  83. ' Shortens the system menu...
  84. ' Put 'CutSystemMenu Me,x' into the 'Form_Load' of every Form you need it for.
  85. ' Modify with other given (see GENERAL) variables.
  86. '
  87. Sub CutSystemMenu (Form As Form, Menu%)
  88.  
  89. Dim hMenu%
  90.  
  91.     hMenu = GetSystemMenu(Form.hWnd, 0)
  92.     
  93.     If Menu And 1 Then retInt = DeleteMenu(hMenu, SC_SIZE, 0)   ' Form is unsizable...
  94.     If Menu And 2 Then retInt = DeleteMenu(hMenu, SC_CLOSE, 0)  ' No Exit with system menu...
  95.  
  96.     retInt = DeleteMenu(hMenu, SC_TASKLIST, 0)
  97.     
  98.     ' And not to forget the separators...
  99.     retInt = DeleteMenu(hMenu, SC_SEPARATOR, 0)
  100.     If Menu And 2 Then retInt = DeleteMenu(hMenu, SC_SEPARATOR, 0)
  101.  
  102. End Sub
  103.  
  104. Sub Define3D (Form3D As Form)
  105.  
  106. ' If we have 3D...
  107. If CTRL3D_Registered = False Then Exit Sub
  108.  
  109. ' ...allow only FIXED_DOUBLE borders...
  110. If Form3D.BorderStyle <> FIXED_DOUBLE Then Exit Sub
  111.  
  112.     Form3D.BackColor = COLOR_BTNFACE
  113.      
  114.     ' ...alter the frame so that 3D can affect it...
  115.     retLng = SetWindowLong(Form3D.hWnd, GWL_STYLE, GetWindowLong(Form3D.hWnd, GWL_STYLE) Or DS_MODALFRAME)
  116.         
  117.     ' ...select the proper 3D-DLL and '3D' this form.
  118.     Select Case CTRL3D_Registered
  119.         Case 1: Ctl3dSubclassDlgEx Form3D.hWnd, &H0
  120.         Case 2: Ctl3dSubclassDlgExV2 Form3D.hWnd, &H0
  121.     End Select
  122.  
  123. End Sub
  124.  
  125. '
  126. ' Replaces old code ! (This one is safer)
  127. '
  128. Function DirExists% (Path$)
  129.  
  130. ' Be sure that there is no terminating backslash
  131. If Right$(Path, 1) = "\" Then Path = Left$(Path, Len(Path) - 1)
  132.  
  133. On Error Resume Next
  134.  
  135.     ' ATTR_DIRECTORY = 16
  136.     retInt = Len(Dir$(Path, 16))
  137.     
  138.     If retInt = 0 Or Err Then
  139.             DirExists = False
  140.         Else
  141.             DirExists = (GetAttr(Path) And 16)
  142.     End If
  143.  
  144. End Function
  145.  
  146. '
  147. ' Replaces old code ! (This one is safer)
  148. '
  149. Function FileExists% (File$)
  150.  
  151. On Error Resume Next
  152.  
  153.     ' ATTR_HIDDEN = 2; ATTR_SYSTEM = 4
  154.     ' ATTR_HIDDEN or ATTR_SYSTEM = 6
  155.     retInt = Len(Dir$(File, 6))
  156.     
  157.     If retInt = 0 Or Err Then
  158.             FileExists = False
  159.         Else
  160.             FileExists = Not (GetAttr(File) And 16)
  161.     End If
  162.  
  163. End Function
  164.  
  165. Sub Register3D ()
  166.  
  167. ' Offer the opportunity to run this application without 3D.
  168. ' --> All programs by ChG_Tools bear this (partly) undocumented command
  169. If InStr(1, Command$, "/NO3D", 1) Then Exit Sub
  170.  
  171. Dim oldErrorMode%
  172.  
  173. On Error Resume Next
  174.  
  175. ' Windows does NOT display an error message box now
  176. ' when it fails to find one of the following files.
  177. oldErrorMode = SetErrorMode(SEM_NOOPENFILEERRORBOX)
  178.     
  179.     'Get the instance handle of the module that owns the window.
  180.     hInst = GetWindowWord(Forms(0).hWnd, GWW_HINSTANCE)
  181.     
  182.         ' Register CTL3D.DLL...
  183.         Ctl3dRegister hInst
  184.  
  185.     ' ...and if no error occured...
  186.     If Err = 0 Then
  187.             ' ...make it perfect.
  188.             Ctl3dAutoSubclass hInst
  189.             CTRL3D_Registered = 1
  190.         Else
  191.             ' In case we had an error (CTL3D.DLL not found)...
  192.             Err = False
  193.                 
  194.                 ' ,,,register CTL3DV2.DLL...
  195.                 Ctl3dRegisterV2 hInst
  196.             
  197.             ' ...and if no error occured now...
  198.             If Err = 0 Then
  199.                     ' ...make it perfect with this one.
  200.                     Ctl3dAutoSubclassV2 hInst
  201.                     CTRL3D_Registered = 2
  202.             End If
  203.     End If
  204.  
  205. ' Reset the ErrorMode (just to tidy up).
  206. oldErrorMode = SetErrorMode(oldErrorMode)
  207.  
  208. End Sub
  209.  
  210. '
  211. ' Correct use of the original Windows AboutBox...
  212. '
  213. ' And you MUST try again this here:
  214. ' Open the box, hold down Shift+Ctrl and doubleclick the Logo, then close the box.
  215. ' And play it again... as often as you like ! (...and wonder why...)
  216. ' --> To see the original Windows-bitmap exchange 'Icon' against '0&'.
  217. '
  218. Sub ShowAboutBox (Form As Form)
  219.  
  220.     ShellAbout Form.hWnd, "MyApp", "1st Author's Line" + Chr$(10) + "2nd Author's Line", Form.Icon
  221.  
  222. End Sub
  223.  
  224. '
  225. ' Not needed in this application.
  226. ' Whereever you need the SYSTEM-directory use the 'SysDir()' command.
  227. '
  228. Function SysDir$ ()
  229.  
  230. Dim GetSysDir$
  231.  
  232.     GetSysDir = Space(144) ' or 144<
  233.     retInt = GetSystemDirectory(GetSysDir, 144)
  234.     GetSysDir = Left$(GetSysDir, retInt)
  235.  
  236. SysDir = Backslash(GetSysDir)
  237.  
  238. End Function
  239.  
  240. Sub Unregister3D ()
  241.  
  242. ' If we have 3D...
  243. If CTRL3D_Registered = False Then Exit Sub
  244.          
  245.         '...get the instance handle of the module again that owns the window...
  246.         hInst = GetWindowWord(Forms(0).hWnd, GWW_HINSTANCE)
  247.     
  248.         ' ...select the proper 3D-DLL and unregister.
  249.         Select Case CTRL3D_Registered
  250.             Case 1: Ctl3dUnregister hInst
  251.             Case 2: Ctl3dUnregisterV2 hInst
  252.         End Select
  253.         
  254. ' >>(Only needed if you swith 3D on and off at runtime)
  255. '    CTRL3D_Registered = False
  256.  
  257. End Sub
  258.  
  259. '
  260. ' Not needed in this application.
  261. ' Whereever you need the WINDOWS-directory use the 'WinDir()' command.
  262. ''
  263. Function WinDir$ ()
  264.  
  265. Dim GetWinDir$
  266.  
  267.     GetWinDir = Space(144) ' or 144<
  268.     retInt = GetWindowsDirectory(GetWinDir, 144)
  269.     GetWinDir = Left$(GetWinDir, retInt)
  270.  
  271. WinDir = Backslash(GetWinDir)
  272.  
  273. End Function
  274.  
  275.